home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d26 / csa.arc / INIT.LSP < prev    next >
Lisp/Scheme  |  1987-05-22  |  3KB  |  105 lines
  1. ; initialization file for XLISP 1.7
  2. ; ccl (1/29/87),(3/2/87),(3/19/87)
  3. ; get some more memory
  4. (princ "XLISP initialization")
  5. (terpri)
  6. (expand 6)
  7. ;(princ "\16[?7h")
  8. (setq __file "noname.lsp")
  9. (princ "define: ");
  10. (princ "save, ")
  11. ; (save fun) - save a function definition to a file
  12. (defmacro save (fun)
  13.          `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  14.                  (fval (car ,fun))
  15.                  (fp (openo fname)))
  16.                 (cond (fp (print (cons (if (eq (car fval) 'lambda)
  17.                                            'defun
  18.                                            'defmacro)
  19.                                        (cons ',fun (cdr fval))) fp)
  20.                           (close fp)
  21.                           fname)
  22.                       (t nil))))
  23.  
  24. (princ "ed, ")
  25.  
  26. ; define edit function to edit program loaded with 'ld'
  27. ; resets wrap around on since sedt leaves it off
  28.  
  29. (defun ed ()
  30.     (dos (strcat "SEDT " __file ".lsp"))
  31. ;    (princ "\16[?7h")
  32.     (load __file))
  33.  
  34. (princ "ld, ")
  35.  
  36. ; define load function to save file name and load file
  37.  
  38. (defun ld (fn)
  39.     (setq __file fn)
  40. ;    (princ "\16[?7h")
  41.     (load fn)
  42. )
  43.  
  44. ; define edit function to edit a file (no .LSP appended) and NOT reload it
  45. (defun edit (fn)
  46.     (dos (strcat "SEDT " fn)))
  47.  
  48. (princ "break, ")
  49. (defun break ()
  50.        (setq *breakenable* t))
  51.  
  52. (princ "nobreak, ")
  53. (defun nobreak ()
  54.        (setq *breakenable* nil))
  55.  
  56. (princ "debug, ")
  57. (defun debug ()
  58.     (setq *tracenable* t)
  59. )
  60.  
  61. (princ "nodebug, ")
  62. (defun nodebug ()
  63.     (setq *tracenable* nil)
  64. )
  65.  
  66. ; define functions to allow trace/untrace of functions
  67. ; original by dave wecker
  68.  
  69. (defun evalhookfcn (expr env &aux val)
  70.     (if (and (consp expr) (member (car expr) *tracelist*))
  71.         (progn (dotimes (a *tracedepth*) (princ "-"))
  72.             (princ ">> ")
  73.             (princ expr)
  74.             (princ " ")
  75.             (if (consp env) (princ env))
  76.             (terpri)
  77.             (setq *tracedepth* (1+ *tracedepth*))
  78.             (setq val (evalhook expr evalhookfcn nil env))
  79.             (setq *tracedepth* (1- *tracedepth*))
  80.             (dotimes (a *tracedepth*) (princ "-"))
  81.             (princ "<< ") (print val))
  82.         (evalhook expr evalhookfcn nil env)))
  83.  
  84. (princ "trace, ")
  85. (defun trace (fun)
  86.     (setq *evalhook* evalhookfcn)
  87.     (if (not (member fun *tracelist*))
  88.         (setq *tracelist* (cons fun *tracelist*)))
  89.     *tracelist*)
  90.  
  91. (princ "notrace")
  92. (defun notrace (fun)
  93.     (if (null (setq *tracelist* (delete fun *tracelist*)))
  94.         (setq *evalhook* nil))
  95.     *tracelist*)
  96.  
  97. ; initialize debug symbols
  98.  
  99. (setq *breakenable* t)      ; allow breaks
  100. (setq *tracenable* nil)     ; no traceback info
  101. (setq *tracelist* nil)      ; no function trace
  102. (setq *tracedepth* 0)       ; no function trace
  103. (terpri)
  104. (terpri)
  105.